
{***********************************************************}
{                                                           }
{      Luxena Database Library                              }
{                                                           }
{      SQL Generation & Parsing                             }
{                                                           }
{      Copyright (c) 2001-2008 Luxena Software Company      }
{      http://www.luxena.com                                }
{      e-mail: support@luxena.com                           }
{                                                           }
{***********************************************************}

unit LXSQLProcessor;

{$I lx.inc}

interface

uses Classes, DB, LXMacroSQL;

const
  LX_DEFAULT_ORACLE_LOB = True;
  LX_DEFAULT_ENABLED    = True;
  LX_DEFAULT_PARAM_CHAR = ':';
  LX_DEFAULT_MACRO_CHAR = '%';

type

{ TLXSQLGenerator }

  TLXSQLGenerator = class
  private
    FFields: TFields;
    FIsSQLBased: Boolean;
    FQuoteChar: string;
    FQuotedTable: string;
    FQuotedTableDot: string;
    FHasObjects: Boolean;
    FParamChar: Char;
    FOracleLob: Boolean;
    FCustomFilter: string;
    FUpdateMode: TUpdateMode;
    procedure InitializeMetadata(const TableName: string);
    function UseFieldInUpdate(Field: TField; UpdateKind: TUpdateKind): Boolean;
    function UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
    function GetQuotedFullName(Field: TField): string;
    function GetQuotedOriginalName(Field: TField): string;
    function GenerateInsertSQL: string;
    function GenerateUpdateSQL: string;
    function GenerateDeleteSQL: string;
    function GenerateModifyWhereSQL(UpdateMode: TUpdateMode; const Alias: string): string;
    function GenerateOracleReturning(UpdateKind: TUpdateKind): string;
    function GenerateRefreshWhereSQL(UpdateMode: TUpdateMode; const Alias: string): string;
  public
    constructor Create(IsSQLBased: Boolean; const QuoteChar, TableName: string;
      Fields: TFields);
    function GetParamStr(const Prefix, FieldName: string): string; overload;
    function GetParamStr(const Prefix: string; Field: TField): string; overload;
    function GenerateModifySQL(UpdateKind: TUpdateKind): string;
    function GenerateRefreshSQL: string;
    property ParamChar: Char read FParamChar write FParamChar;
    property OracleLob: Boolean read FOracleLob write FOracleLob;
    property CustomFilter: string read FCustomFilter write FCustomFilter;
    property UpdateMode: TUpdateMode read FUpdateMode write FUpdateMode; 
  end;


{ TLXSQLProcessor }

  TLXSQLProcessor = class(TComponent)
  private
    FEnabled: Boolean;
    FParamChar: Char;
    FMacroChar: Char;
    FMacros: TStrings;
    FOracleLob: Boolean;
    procedure SetParamChar(const Value: Char);
    procedure SetMacroChar(const Value: Char);
    procedure SetMacros(const Value: TStrings);
    function GetParser: ILXMacroSQLParser;
    function CreateFullMacros(Macros: TStrings): TStrings;
  protected
    property OracleLob: Boolean read FOracleLob write FOracleLob default LX_DEFAULT_ORACLE_LOB;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Parse(const SQL: string): TLXMacroSQLElement;
    function Build(MacroSQLElement: TLXMacroSQLElement; Macros: TStrings): ILXMacroSQLResult;
    function ParseAndBuild(const SQL: string; Macros: TStrings): ILXMacroSQLResult;
    function CreateSQLGenerator(IsSQLBased: Boolean; const QuoteChar: string;
      const TableName: string; Fields: TFields): TLXSQLGenerator;
  published
    property Enabled: Boolean read FEnabled write FEnabled default LX_DEFAULT_ENABLED;
    property Macros: TStrings read FMacros write SetMacros;
    property ParamChar: Char read FParamChar write SetParamChar default LX_DEFAULT_PARAM_CHAR;
    property MacroChar: Char read FMacroChar write SetMacroChar default LX_DEFAULT_MACRO_CHAR;
  end;


implementation

uses SysUtils, LXConsts, LXDBConsts, LXVariants;


{ TLXSQLGenerator }

constructor TLXSQLGenerator.Create(IsSQLBased: Boolean;
  const QuoteChar, TableName: string; Fields: TFields);
begin
  inherited Create;
  FIsSQLBased := IsSQLBased;
  FQuoteChar := QuoteChar;
  FFields := Fields;
  FParamChar := LX_DEFAULT_PARAM_CHAR;
  FOracleLob := True;
  InitializeMetadata(TableName);
end;

procedure TLXSQLGenerator.InitializeMetadata(const TableName: string);

  function GetQuotedTableName(SQLBased: Boolean; const QuoteChar, TableName: string): string;
  var
    DotPos, DotPos2: Integer;
  begin
    Result := '';
    if TableName <> '' then
    begin
      if (TableName[1] in ['''','"','`']) or (TableName[Length(TableName)] in ['''','"','`']) then
        Result := TableName else
      begin
        if not SQLBased then
          Result := QuoteChar + TableName + QuoteChar else
        begin
          Result := TableName;
          DotPos := Pos('.', Result);
          DotPos2 := Pos('.',PChar(Result) + DotPos);
          if DotPos2 <> 0 then
            DotPos2 := DotPos2 + DotPos;
          if (DotPos <> 0) and (DotPos2 <> 0 ) then
          begin
            System.Insert(QuoteChar, Result, DotPos2);
            System.Insert(QuoteChar, Result, DotPos2 + 2);
            System.Insert(QuoteChar, Result, DotPos + 1);
            System.Insert(QuoteChar, Result, DotPos);
          end else
            if DotPos <> 0 then
            begin
              System.Insert(QuoteChar, Result, DotPos + 1);
              System.Insert(QuoteChar, Result, DotPos);
            end;
          Result := QuoteChar + Result + QuoteChar;
        end;
      end;
    end;
  end;

var
  I: Integer;
begin
  if TableName <> '' then
    if not IsValidIdent(TableName) then
      FQuotedTable := GetQuotedTableName(FIsSQLBased, FQuoteChar, TableName) else
      FQuotedTable := TableName;
  if FIsSQLBased then
    FQuotedTableDot := '' else
    FQuotedTableDot := FQuotedTable + '.';
  FHasObjects := False;
  for I := 0 to FFields.Count - 1 do
    if (FFields[I] is TObjectField) and
       (TObjectField(FFields[I]).ObjectType <> '') then
    begin
      FHasObjects := True;
      Break;
    end;
end;

function TLXSQLGenerator.UseFieldInUpdate(Field: TField; UpdateKind: TUpdateKind): Boolean;
const
  ExcludedTypes = [ftUnknown, ftCursor, ftADT, ftArray, ftReference, ftDataSet];
begin
  with Field do
    Result := (pfInUpdate in ProviderFlags) and not (DataType in ExcludedTypes) and
      not ((UpdateKind = ukModify) and (DataType = ftAutoInc)) and 
      not ReadOnly and (FieldKind = fkData) and not (pfHidden in ProviderFlags) and
      not LXVarIsClear(NewValue);
end;

function TLXSQLGenerator.UseFieldInWhere(Field: TField; Mode: TUpdateMode): Boolean;
const
  ExcludedTypes = [ftDataSet, ftADT, ftArray, ftReference, ftCursor, ftUnknown];
begin
  with Field do
  begin
    Result := (FieldKind = fkData) and not IsBlob and not (DataType in ExcludedTypes);
    if Result then
      case Mode of
        upWhereAll:
          Result := pfInWhere in ProviderFlags;
        upWhereChanged:
          Result := (pfInKey in ProviderFlags) or
            ((pfInWhere in ProviderFlags) and not LXVarIsClear(NewValue));
        upWhereKeyOnly:
          Result := pfInKey in ProviderFlags;
      end;
  end;
end;

function TLXSQLGenerator.GetQuotedFullName(Field: TField): string;
var
  I: Integer;
  P: PChar;
  FullName: string;
begin
  FullName := Field.FullName;
  if (Length(FullName) > 1) and (FullName[1] in [#0, #1]) then
    P := @FullName[2] else
    P := PChar(FullName);
  Result := FQuoteChar + P + FQuoteChar;
  for I := Length(Result) downto 1 do
    if Result[I] = '.' then
    begin
      System.Insert(FQuoteChar, Result, I + 1);
      System.Insert(FQuoteChar, Result, I);
    end;
end;

function TLXSQLGenerator.GetQuotedOriginalName(Field: TField): string;
begin
  if Field.Origin <> '' then
    Result := Field.Origin else
    Result := Field.FieldName;
  Result := FQuotedTableDot + FQuoteChar + Result + FQuoteChar;
end;

function TLXSQLGenerator.GenerateModifyWhereSQL(UpdateMode: TUpdateMode;
  const Alias: string): string;

  function AddField(Field: TField; InObject: Boolean; var SQL, Separator: string): Boolean;
  var
    I: Integer;
    Condition, Expression: string;
  begin
    Result := False;
    if Field.DataType = ftADT then
    begin
      for I := 0 to TObjectField(Field).FieldCount - 1 do
        if AddField(TObjectField(Field).Fields[I], True, SQL, Separator) then
          Result := True;
    end else
      if UseFieldInWhere(Field, UpdateMode) then
      begin
        if InObject then
        begin
          if LXVarIsNull(Field.OldValue) then
            Condition := ' is null' else
            Condition := ' = ' + GetParamStr('OLD_', Field);
          Expression := Alias + '.' + GetQuotedFullName(Field) + Condition;
        end else
        begin
          if LXVarIsNull(Field.OldValue) or (not FIsSQLBased and
             (Field.DataType = ftString) and (Length(Field.OldValue) = 0)) then
            Condition := ' is null' else
            Condition := ' = ' + GetParamStr('OLD_', Field);
          Expression := GetQuotedOriginalName(Field) + Condition;
        end;
        SQL := SQL + (Separator + Expression);
        Separator := ' and' + SLineBreak + '  ';
        Result := True;
      end;
  end;

var
  I: Integer;
  Separator: string;
  Added: Boolean;
begin
  if FCustomFilter <> '' then
    Result := FCustomFilter else
  begin
    Added := False;
    for I := 0 to FFields.Count - 1 do
      if AddField(FFields[I], False, Result, Separator) then
        Added := True;
    if not Added then
      DatabaseError(SNoKeySpecified);
  end;
  
  Result := SLineBreak + 'where' + SLineBreak + '  ' + Result;
end;

function TLXSQLGenerator.GenerateOracleReturning(UpdateKind: TUpdateKind): string;
var
  I: Integer;
  FieldList, ParamList: string;
  Separator: string;
  Field: TField;
begin
  if not OracleLob then Exit;
  Separator := '  ';
  for I := 0 to FFields.Count - 1 do
  begin
    Field := FFields[I];
    if (Field.DataType in [ftOraClob, ftOraBlob]) and
      UseFieldInUpdate(Field, UpdateKind) then
    begin
      FieldList := FieldList + Separator + GetQuotedFullName(Field);
      ParamList := ParamList + Separator + GetParamStr('', Field);
      Separator := ', ';
    end;
  end;
  if FieldList <> '' then
    Result := SLineBreak + 'returning' + SLineBreak + FieldList + SLineBreak +
      'into' + SLineBreak + ParamList;
end;

function TLXSQLGenerator.GenerateRefreshWhereSQL(UpdateMode: TUpdateMode;
  const Alias: string): string;

  function AddField(Field: TField; InObject: Boolean; var SQL, Separator: string): Boolean;
  var
    I: Integer;
    FieldValue: Variant;
    Condition, Expression: string;
  begin
    Result := False;
    if Field.DataType = ftADT then
    begin
      for I := 0 to TObjectField(Field).FieldCount - 1 do
        if AddField(TObjectField(Field).Fields[I], True, SQL, Separator) then
          Result := True;
    end else
      if UseFieldInWhere(Field, UpdateMode) then
      begin
        if LXVarIsClear(Field.NewValue) then
          FieldValue := Field.OldValue else
          FieldValue := Field.NewValue;
        if InObject then
        begin
          if LXVarIsNull(FieldValue) then
            Condition := ' is null' else
            Condition := ' = ' + GetParamStr('', Field);
          Expression := Alias + '.' + GetQuotedFullName(Field) + Condition;
        end else
        begin
          if LXVarIsNull(FieldValue) or (not FIsSQLBased and
             (Field.DataType = ftString) and (Length(FieldValue) = 0)) then
            Condition := ' is null' else
            Condition := ' = ' + GetParamStr('', Field);
          Expression := GetQuotedOriginalName(Field) + Condition;
        end;
        SQL := SQL + (Separator + Expression);
        Separator := ' and' + SLineBreak + '  ';
        Result := True;
      end;
  end;

var
  I: Integer;
  Separator: string;
  Added: Boolean;
begin
  if FCustomFilter <> '' then
    Result := FCustomFilter else
  begin
    Added := False;
    Separator := '  ';
    for I := 0 to FFields.Count - 1 do
      if AddField(FFields[I], False, Result, Separator) then
        Added := True;
    if not Added then
      DatabaseError(SNoKeySpecified);
  end;
  
  Result := SLineBreak + 'where' + SLineBreak + '  ' + Result;
end;


function TLXSQLGenerator.GenerateInsertSQL: string;

  procedure AddField(Field: TField; var FieldList, ParamList, Separator: string);
  var
    I: Integer;
    TempStr: string;
    ParamStr: string;
  begin
    if Field.DataType in [ftADT, ftArray] then
    begin
      ParamStr := TObjectField(Field).ObjectType + '(';
      Separator := '';
      for I := 0 to TObjectField(Field).FieldCount - 1 do
        AddField(TObjectField(Field).Fields[I], TempStr, ParamStr, Separator);
      ParamStr := ParamStr + ')';
    end else
      if (Field.DataType = ftDataSet) and (TObjectField(Field).ObjectType <> '') then
        ParamStr := TObjectField(Field).ObjectType + '()'
      else
        if UseFieldInUpdate(Field, ukInsert) or ((Field.ParentField <> nil) and
          (Field.ParentField.DataType in [ftADT, ftArray, ftReference]) and
          Field.IsNull) then
        begin
          if OracleLob and (Field.DataType = ftOraBlob) then
            ParamStr := 'empty_blob()'
          else if OracleLob and (Field.DataType = ftOraClob) then
            ParamStr := 'empty_clob()'
          else if (Field.ParentField <> nil) and Field.IsNull then
            ParamStr := 'null'
          else
            ParamStr := GetParamStr('', Field);
        end;

    if ParamStr <> '' then
    begin
      FieldList := FieldList + Separator + GetQuotedOriginalName(Field);
      ParamList := ParamList + Separator + ParamStr;
      Separator := ', ';
    end;
  end;

var
  I: Integer;
  FieldList, ParamList: string;
  Separator: string;
begin
  for I := 0 to FFields.Count - 1 do
    AddField(FFields[I], FieldList, ParamList, Separator);
  Result :=
    'insert into ' + FQuotedTable + SLineBreak +
    '  (' + FieldList + ')' + SLineBreak +
    'values' + SLineBreak +
    '  (' + ParamList + ')' + GenerateOracleReturning(ukInsert);
end;

function TLXSQLGenerator.GenerateUpdateSQL: string;
var
  Alias: string;
  I: Integer;
  UpdatedFields: string;
  Separator: string;

  procedure AddField(Field: TField; InObject, InArray: Boolean;
    var UpdatedFields, Separator: string);
  var
    I: Integer;
    AssignStr: string;
  begin
    if Field.DataType = ftADT then
    begin
      if InArray then
      begin
        AssignStr := TObjectField(Field).ObjectType + '(';
        Separator := '';
      end;
      for I := 0 to TObjectField(Field).FieldCount - 1 do
        AddField(TObjectField(Field).Fields[I], True, InArray, AssignStr, Separator);
      if InArray then
        AssignStr := AssignStr + ')';
    end else
      if Field.DataType = ftArray then
      begin
        AssignStr := Field.FullName + ' = ' + TObjectField(Field).ObjectType + '(';
        Separator := '';
        for I := 0 to TObjectField(Field).FieldCount - 1 do
          AddField(TObjectField(Field).Fields[I], InObject, True, AssignStr, Separator);
        AssignStr := AssignStr + ')';
      end else
        if InArray then
          AssignStr := GetParamStr('', Field)
        else
          if UseFieldInUpdate(Field, ukModify) then
          begin
            if InObject then
              AssignStr := Alias + '.' + GetQuotedFullName(Field) else
              AssignStr := GetQuotedOriginalName(Field);
            if OracleLob and (Field.DataType = ftOraBlob) then
              AssignStr := AssignStr + ' = empty_blob()'
            else if OracleLob and (Field.DataType = ftOraClob) then
              AssignStr := AssignStr + ' = empty_clob()'
            else
              AssignStr := AssignStr + ' = ' + GetParamStr('', Field);
          end;

    if AssignStr <> '' then
    begin
      UpdatedFields := UpdatedFields + Separator + AssignStr;
      Separator := ', ';
    end;
  end;

begin
  if FHasObjects then Alias := ' T';
  for I := 0 to FFields.Count - 1 do
    AddField(FFields[I], False, False, UpdatedFields, Separator);
  Result :=
    'update ' + FQuotedTable + Alias + SLineBreak + 'set' + SLineBreak +
    '  ' + UpdatedFields + GenerateModifyWhereSQL(UpdateMode, Alias) +
    GenerateOracleReturning(ukModify);
end;

function TLXSQLGenerator.GenerateDeleteSQL: string;
var
  Alias: string;
begin
  if FHasObjects then Alias := ' T';
  Result := 'delete from ' + FQuotedTable + Alias +
    GenerateModifyWhereSQL(UpdateMode, Alias);
end;

function TLXSQLGenerator.GetParamStr(const Prefix,
  FieldName: string): string;
begin
  Result := FParamChar + '"' + Prefix + LowerCase(FieldName) + '"';
end;

function TLXSQLGenerator.GetParamStr(const Prefix: string;
  Field: TField): string;
begin
  Result := GetParamStr(Prefix, Field.FieldName);
end;

function TLXSQLGenerator.GenerateModifySQL(UpdateKind: TUpdateKind): string;
begin
  case UpdateKind of
    ukInsert: Result := GenerateInsertSQL;
    ukModify: Result := GenerateUpdateSQL;
    ukDelete: Result := GenerateDeleteSQL;
  end;
end;

function TLXSQLGenerator.GenerateRefreshSQL: string;
var
  Alias: string;
  I: Integer;
  SelectedFields: string;
  Separator: string;
begin
  if FHasObjects then Alias := ' T';
  for I := 0 to FFields.Count - 1 do
    if FFields[I].FieldKind in [fkData, fkInternalCalc] then
    begin
      SelectedFields := SelectedFields + Separator + FFields[I].FieldName;
      Separator := ', ';
    end;
  Result := 'select ' + SelectedFields + ' from ' + FQuotedTable + Alias +
    GenerateRefreshWhereSQL(UpdateMode, Alias);
end;


{ TLXSQLProcessor }

constructor TLXSQLProcessor.Create(AOwner: TComponent);
begin
  inherited;
  FEnabled := LX_DEFAULT_ENABLED;
  FParamChar := LX_DEFAULT_PARAM_CHAR;
  FMacroChar := LX_DEFAULT_MACRO_CHAR;
  FMacros := TStringList.Create;
  FOracleLob := LX_DEFAULT_ORACLE_LOB;
end;

destructor TLXSQLProcessor.Destroy;
begin
  FMacros.Free;
  inherited;
end;

procedure TLXSQLProcessor.SetParamChar(const Value: Char);
begin
  FParamChar := Value;
end;

procedure TLXSQLProcessor.SetMacroChar(const Value: Char);
begin
  FMacroChar := Value;
end;

procedure TLXSQLProcessor.SetMacros(const Value: TStrings);
begin
  FMacros.Assign(Value);
end;

function TLXSQLProcessor.GetParser: ILXMacroSQLParser;
begin
  Result := TLXMacroSQLParser.Create(FParamChar, FMacroChar);
end;

function TLXSQLProcessor.CreateFullMacros(Macros: TStrings): TStrings;
var
  I: Integer;
begin
  Result := TStringList.Create;
  if Macros = nil then
    Result.Assign(FMacros) else
  begin
    for I := 0 to FMacros.Count - 1 do
      if (Macros.IndexOf(FMacros[I]) < 0) and (Macros.IndexOfName(FMacros.Names[I]) < 0) then
        Result.Add(FMacros[I]);
    Result.AddStrings(Macros);
  end;
end;

function TLXSQLProcessor.Parse(const SQL: string): TLXMacroSQLElement;
begin
  if FEnabled then
    Result := GetParser.Parse(SQL) else
    Result := TLXMacroSQLText.Create(SQL);
end;

function TLXSQLProcessor.Build(MacroSQLElement: TLXMacroSQLElement;
  Macros: TStrings): ILXMacroSQLResult;
var
  FullMacros: TStrings;
  MacroSQLBuilder: TLXMacroSQLBuilder;
begin
  FullMacros := CreateFullMacros(Macros);
  try
    MacroSQLBuilder := TLXMacroSQLBuilder.Create(GetParser, FullMacros);
    Result := MacroSQLBuilder;
    MacroSQLElement.Accept(MacroSQLBuilder);
  finally
    FullMacros.Free;
  end;
end;

function TLXSQLProcessor.ParseAndBuild(const SQL: string;
  Macros: TStrings): ILXMacroSQLResult;
var
  MacroSQLElement: TLXMacroSQLElement;
begin
  MacroSQLElement := Parse(SQL);
  try
    Result := Build(MacroSQLElement, Macros);
  finally
    MacroSQLElement.Free;
  end;
end;

function TLXSQLProcessor.CreateSQLGenerator(IsSQLBased: Boolean; const QuoteChar: string;
  const TableName: string; Fields: TFields): TLXSQLGenerator;
begin
  Result := TLXSQLGenerator.Create(IsSQLBased, QuoteChar, TableName, Fields);
  Result.ParamChar := ParamChar;
  Result.OracleLob := OracleLob;
end;


end.